QBasic & Borland Pascal & C/Delphi5.iso/Basic/Visual Basic.60/VB98/WIZARDS/APPWIZ.OCX/1033/TEXT/STDINFO

Text File | 1998-06-26 | 20.0 KB | 684 lines

*ABOUTFRM
' Reg Key Security Options...
Const KEY_ALL_ACCESS = &H2003F

' Reg Key ROOT Types...
Const HKEY_LOCAL_MACHINE = &H80000002
Const ERROR_SUCCESS = 0
Const REG_SZ = 1                         ' Unicode nul terminated string
Const REG_DWORD = 4                      ' 32-bit number

Const gREGKEYSYSINFOLOC = "SOFTWARE\Microsoft\Shared Tools Location"
Const gREGVALSYSINFOLOC = "MSINFO"
Const gREGKEYSYSINFO = "SOFTWARE\Microsoft\Shared Tools\MSINFO"
Const gREGVALSYSINFO = "PATH"

Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long

Private Sub cmdSysInfo_Click()
    Call StartSysInfo
End Sub

Private Sub cmdOK_Click()
    Unload Me
End Sub

Public Sub StartSysInfo()
  On Error GoTo SysInfoErr

    Dim rc As Long
    Dim SysInfoPath As String

    ' Try To Get System Info Program Path\Name From Registry...
    If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFO, gREGVALSYSINFO, SysInfoPath) Then
    ' Try To Get System Info Program Path Only From Registry...
    ElseIf GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFOLOC, gREGVALSYSINFOLOC, SysInfoPath) Then
        ' Validate Existance Of Known 32 Bit File Version
        If (Dir(SysInfoPath & "\MSINFO32.EXE") <> "") Then
            SysInfoPath = SysInfoPath & "\MSINFO32.EXE"

        ' Error - File Can Not Be Found...
        Else
            GoTo SysInfoErr
        End If
    ' Error - Registry Entry Can Not Be Found...
    Else
        GoTo SysInfoErr
    End If

    Call Shell(SysInfoPath, vbNormalFocus)

    Exit Sub
SysInfoErr:
    MsgBox "System Information Is Unavailable At This Time", vbOKOnly
End Sub

Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, ByRef KeyVal As String) As Boolean
    Dim i As Long                                           ' Loop Counter
    Dim rc As Long                                          ' Return Code
    Dim hKey As Long                                        ' Handle To An Open Registry Key
    Dim hDepth As Long                                      '
    Dim KeyValType As Long                                  ' Data Type Of A Registry Key
    Dim tmpVal As String                                    ' Tempory Storage For A Registry Key Value
    Dim KeyValSize As Long                                  ' Size Of Registry Key Variable
    '------------------------------------------------------------
    ' Open RegKey Under KeyRoot {HKEY_LOCAL_MACHINE...}
    '------------------------------------------------------------
    rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' Open Registry Key

    If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' Handle Error...

    tmpVal = String$(1024, 0)                             ' Allocate Variable Space
    KeyValSize = 1024                                       ' Mark Variable Size

    '------------------------------------------------------------
    ' Retrieve Registry Key Value...
    '------------------------------------------------------------
    rc = RegQueryValueEx(hKey, SubKeyRef, 0, KeyValType, tmpVal, KeyValSize)    ' Get/Create Key Value

    If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' Handle Errors

    tmpVal = VBA.Left(tmpVal, InStr(tmpVal, VBA.Chr(0)) - 1)
    '------------------------------------------------------------
    ' Determine Key Value Type For Conversion...
    '------------------------------------------------------------
    Select Case KeyValType                                  ' Search Data Types...
    Case REG_SZ                                             ' String Registry Key Data Type
        KeyVal = tmpVal                                     ' Copy String Value
    Case REG_DWORD                                          ' Double Word Registry Key Data Type
        For i = Len(tmpVal) To 1 Step -1                    ' Convert Each Bit
            KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1)))   ' Build Value Char. By Char.
        Next
        KeyVal = Format$("&h" + KeyVal)                     ' Convert Double Word To String
    End Select

    GetKeyValue = True                                      ' Return Success
    rc = RegCloseKey(hKey)                                  ' Close Registry Key
    Exit Function                                           ' Exit

GetKeyError:    ' Cleanup After An Error Has Occured...
    KeyVal = ""                                             ' Set Return Val To Empty String
    GetKeyValue = False                                     ' Return Failure
    rc = RegCloseKey(hKey)                                  ' Close Registry Key
End Function
*END

*LOGINFRM
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpbuffer As String, nSize As Long) As Long

Public OK As Boolean

Private Sub cmdCancel_Click()
  OK = False
  Me.Hide
End Sub

Private Sub cmdOK_Click()
  'ToDo: create test for correct password
  'check for correct password
  If txtPassword.Text = "" Then
    OK = True
    Me.Hide
  Else
    MsgBox "Invalid Password, try again!", , "Login"
    txtPassword.SetFocus
    txtPassword.SelStart = 0
    txtPassword.SelLength = Len(txtPassword.Text)
  End If
End Sub
*END

*OPTIONFRM
Private Sub cmdApply_Click()
  'ToDo: Add 'cmdApply_Click' code.
  MsgBox "Apply Code goes here to set options w/o closing dialog!"
End Sub

Private Sub cmdCancel_Click()
  Unload Me
End Sub

Private Sub cmdOK_Click()
  'ToDo: Add 'cmdOK_Click' code.
  MsgBox "Code goes here to set options and close dialog!"
  Unload Me
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  Dim i As Integer
  i = tbsOptions.SelectedItem.index
  'handle ctrl+tab to move to the next tab
  If (Shift And 3) = 2 And KeyCode = vbKeyTab Then
    If i = tbsOptions.Tabs.Count Then
      'last tab so we need to wrap to tab 1
      Set tbsOptions.SelectedItem = tbsOptions.Tabs(1)
    Else
      'increment the tab
      Set tbsOptions.SelectedItem = tbsOptions.Tabs(i + 1)
    End If
  ElseIf (Shift And 3) = 3 And KeyCode = vbKeyTab Then
    If i = 1 Then
      'last tab so we need to wrap to tab 1
      Set tbsOptions.SelectedItem = tbsOptions.Tabs(tbsOptions.Tabs.Count)
    Else
      'increment the tab
      Set tbsOptions.SelectedItem = tbsOptions.Tabs(i - 1)
    End If
  End If
End Sub

Private Sub tbsOptions_Click()

  Dim i As Integer
  'show and enable the selected tab's controls
  'and hide and disable all others
  For i = 0 To tbsOptions.Tabs.Count - 1
    If i = tbsOptions.SelectedItem.Index - 1 Then
      picOptions(i).Left = 210
      picOptions(i).Enabled = True
    Else
      picOptions(i).Left = -20000
      picOptions(i).Enabled = False
    End If
  Next

End Sub
*END

*MENU_OPEN_SDI
  Dim sFile As String

  With dlgCommonDialog
    .DialogTitle = "Open"
    .CancelError = False
    'ToDo: set the flags and attributes of the common dialog control
    .Filter = "All Files (*.*)|*.*"
    .ShowOpen
    If Len(.FileName) = 0 Then
      Exit Sub
    End If
    sFile = .FileName
  End With
  'ToDo: add code to process the opened file
*END

*MENU_SAVEAS_SDI
  'ToDo: Setup the common dialog control prior to calling ShowSave
  With dlgCommonDialog
    .DialogTitle = "Save As"
    .CancelError = False
    .ShowSave
  End With
*END

*MENU_OPEN_MDI
  Dim sFile As String

  If ActiveForm Is Nothing Then LoadNewDoc

  With dlgCommonDialog
    .DialogTitle = "Open"
    .CancelError = False
    'ToDo: set the flags and attributes of the common dialog control
    .Filter = "All Files (*.*)|*.*"
    .ShowOpen
    If Len(.filename) = 0 Then
      Exit Sub
    End If
    sFile = .filename
  End With
  ActiveForm.rtfText.LoadFile sFile
  ActiveForm.Caption = sFile
*END

*MENU_SAVE_MDI
  Dim sFile As String
  If Left$(ActiveForm.Caption, 8) = "Document" Then
    With dlgCommonDialog
      .DialogTitle = "Save"
      .CancelError = False
      'ToDo: set the flags and attributes of the common dialog control
      .Filter = "All Files (*.*)|*.*"
      .ShowSave
      If Len(.filename) = 0 Then
        Exit Sub
      End If
      sFile = .filename
    End With
    ActiveForm.rtfText.SaveFile sFile
  Else
    sFile = ActiveForm.Caption
    ActiveForm.rtfText.SaveFile sFile
  End If
*END

*MENU_SAVEAS_MDI
  Dim sFile As String

  If ActiveForm Is Nothing Then Exit Sub

  With dlgCommonDialog
    .DialogTitle = "Save As"
    .CancelError = False
    'ToDo: set the flags and attributes of the common dialog control
    .Filter = "All Files (*.*)|*.*"
    .ShowSave
    If Len(.filename) = 0 Then
      Exit Sub
    End If
    sFile = .filename
  End With
  ActiveForm.Caption = sFile
  ActiveForm.rtfText.SaveFile sFile
*END

*MENU_COPY_MDI
  On Error Resume Next
  Clipboard.SetText ActiveForm.rtfText.SelRTF
*END

*MENU_CUT_MDI
  On Error Resume Next
  Clipboard.SetText ActiveForm.rtfText.SelRTF
  ActiveForm.rtfText.SelText = vbNullString
*END

*MENU_PRINT_MDI
  On Error Resume Next
  If ActiveForm Is Nothing Then Exit Sub

  With dlgCommonDialog
    .DialogTitle = "Print"
    .CancelError = True
    .Flags = cdlPDReturnDC + cdlPDNoPageNums
    If ActiveForm.rtfText.SelLength = 0 Then
      .Flags = .Flags + cdlPDAllPages
    Else
      .Flags = .Flags + cdlPDSelection
    End If
    .ShowPrinter
    If Err <> mscomdlg.cdlCancel Then
      ActiveForm.rtfText.SelPrint .hDC
    End If
  End With
*END

*MENU_PASTE_MDI
  On Error Resume Next
  ActiveForm.rtfText.SelRTF = Clipboard.GetText
*END

*MENU_PAGESETUP
  On Error Resume Next
  With dlgCommonDialog
    .DialogTitle = "Page Setup"
    .CancelError = True
    .ShowPrinter
  End With
*END

*MENU_EXIT
  'unload the form
  Unload Me
*END

*MENU_ARRANGEICONS
Const NAME_COLUMN = 0
Const TYPE_COLUMN = 1
Const SIZE_COLUMN = 2
Const DATE_COLUMN = 3

Private Sub mnuVAIByDate_Click()
  'ToDo: Add 'mnuVAIByDate_Click' code.
'  lvListView.SortKey = DATE_COLUMN
End Sub

Private Sub mnuVAIByName_Click()
  'ToDo: Add 'mnuVAIByName_Click' code.
'  lvListView.SortKey = NAME_COLUMN
End Sub

Private Sub mnuVAIBySize_Click()
  'ToDo: Add 'mnuVAIBySize_Click' code.
'  lvListView.SortKey = SIZE_COLUMN
End Sub

Private Sub mnuVAIByType_Click()
  'ToDo: Add 'mnuVAIByType_Click' code.
'  lvListView.SortKey = TYPE_COLUMN
End Sub
*END

*MENU_LISTVIEWMODE
Private Sub mnuListViewMode_Click(Index As Integer)
  On Error Resume Next
  'uncheck the current type
  mnuListViewMode(lvListView.View).Checked = False
  'set the listview mode
  lvListView.View = Index
  'check the new type
  mnuListViewMode(Index).Checked = True
*END

*MENU_LISTVIEWMODE2
  'set the toolbar to the same new type
  Select Case lvListView.View
    Case lvwIcon
      tbToolBar.Buttons(LISTVIEW_MODE0).Value = tbrPressed
    Case lvwSmallIcon
      tbToolBar.Buttons(LISTVIEW_MODE1).Value = tbrPressed
    Case lvwList
      tbToolBar.Buttons(LISTVIEW_MODE2).Value = tbrPressed
    Case lvwReport
      tbToolBar.Buttons(LISTVIEW_MODE3).Value = tbrPressed
  End Select
End Sub
*END

*MENU_HELPCONTENTS
  Dim nRet As Integer

  'if there is no helpfile for this project display a message to the user
  'you can set the HelpFile for your application in the
  'Project Properties dialog
  If Len(App.HelpFile) = 0 Then
    MsgBox "Unable to display Help Contents. There is no Help associated with this project.", vbInformation, Me.Caption
  Else
    On Error Resume Next
    nRet = OSWinHelp(Me.hwnd, App.HelpFile, 3, 0)
    If Err Then
      MsgBox Err.Description
    End If
  End If
*END

*MENU_HELPSEARCH
  Dim nRet As Integer

  'if there is no helpfile for this project display a message to the user
  'you can set the HelpFile for your application in the
  'Project Properties dialog
  If Len(App.HelpFile) = 0 Then
    MsgBox "Unable to display Help Contents. There is no Help associated with this project.", vbInformation, Me.Caption
  Else
    On Error Resume Next
    nRet = OSWinHelp(Me.hwnd, App.HelpFile, 261, 0)
    If Err Then
      MsgBox Err.Description
    End If
  End If
*END


*LOADRES
Sub LoadResStrings(frm As Form)
  On Error Resume Next

  Dim ctl As Control
  Dim obj As Object
  Dim fnt As Object
  Dim sCtlType As String
  Dim nVal As Integer

  'set the form's caption
  frm.Caption = LoadResString(CInt(frm.Tag))

  'set the font
  Set fnt = frm.Font
  fnt.Name = LoadResString(20)
  fnt.Size = CInt(LoadResString(21))

  'set the controls' captions using the caption
  'property for menu items and the Tag property
  'for all other controls
  For Each ctl In frm.Controls
    Set ctl.Font = fnt
    sCtlType = TypeName(ctl)
    If sCtlType = "Label" Then
      ctl.Caption = LoadResString(CInt(ctl.Tag))
    ElseIf sCtlType = "Menu" Then
      ctl.Caption = LoadResString(CInt(ctl.Caption))
    ElseIf sCtlType = "TabStrip" Then
      For Each obj In ctl.Tabs
        obj.Caption = LoadResString(CInt(obj.Tag))
        obj.ToolTipText = LoadResString(CInt(obj.ToolTipText))
      Next
    ElseIf sCtlType = "Toolbar" Then
      For Each obj In ctl.Buttons
        obj.ToolTipText = LoadResString(CInt(obj.ToolTipText))
      Next
    ElseIf sCtlType = "ListView" Then
      For Each obj In ctl.ColumnHeaders
        obj.Text = LoadResString(CInt(obj.Tag))
      Next
    Else
      nVal = 0
      nVal = Val(ctl.Tag)
      If nVal > 0 Then ctl.Caption = LoadResString(nVal)
      nVal = 0
      nVal = Val(ctl.ToolTipText)
      If nVal > 0 Then ctl.ToolTipText = LoadResString(nVal)
    End If
  Next

End Sub
*END

*CHILDFORM
Private Sub Form_Load()
  Form_Resize
End Sub

Private Sub Form_Resize()
  On Error Resume Next
  rtfText.Move 100, 100, Me.ScaleWidth - 200, Me.ScaleHeight - 200
  rtfText.RightMargin = rtfText.Width - 400
End Sub
*END

*TVLV
Dim mbMoving As Boolean
Const sglSplitLimit = 500

Private Sub Form_Resize()
  On Error Resume Next
  If Me.Width < 3000 Then Me.Width = 3000
  SizeControls imgSplitter.Left
End Sub

Private Sub imgSplitter_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  With imgSplitter
    picSplitter.Move .Left, .Top, .Width \ 2, .Height - 20
  End With
  picSplitter.Visible = True
  mbMoving = True
End Sub

Private Sub imgSplitter_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  Dim sglPos As Single

  If mbMoving Then
    sglPos = X + imgSplitter.Left
    If sglPos < sglSplitLimit Then
      picSplitter.Left = sglSplitLimit
    ElseIf sglPos > Me.Width - sglSplitLimit Then
      picSplitter.Left = Me.Width - sglSplitLimit
    Else
      picSplitter.Left = sglPos
    End If
  End If
End Sub

Private Sub imgSplitter_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  SizeControls picSplitter.Left
  picSplitter.Visible = False
  mbMoving = False
End Sub

Private Sub TreeView1_DragDrop(Source As Control, X As Single, Y As Single)
  If Source = imgSplitter Then
    SizeControls X
  End If
End Sub

Sub SizeControls(X As Single)
  On Error Resume Next

  'set the width
  If X < 1500 Then X = 1500
  If X > (Me.Width - 1500) Then X = Me.Width - 1500
  tvTreeView.Width = X
  imgSplitter.Left = X
  lvListView.Left = X + 40
  lvListView.Width = Me.Width - (tvTreeView.Width + 140)
  lblTitle(0).Width = tvTreeView.Width
  lblTitle(1).Left = lvListView.Left + 20
  lblTitle(1).Width = lvListView.Width - 40

  'set the top
*END

*TVLV2A
  If tbToolBar.Visible Then
    tvTreeView.Top = tbToolBar.Height + picTitles.Height
  Else
    tvTreeView.Top = picTitles.Height
  End If

*END

*TVLV2B
  tvTreeView.Top = picTitles.Height

*END

*TVLV3
  lvListView.Top = tvTreeView.Top

  'set the height
  If sbStatusBar.Visible Then
    tvTreeView.Height = Me.ScaleHeight - (picTitles.Top + picTitles.Height + sbStatusBar.Height)
  Else
    tvTreeView.Height = Me.ScaleHeight - (picTitles.Top + picTitles.Height)
  End If

  lvListView.Height = tvTreeView.Height
  imgSplitter.Top = tvTreeView.Top
  imgSplitter.Height = tvTreeView.Height
End Sub
*END

*RESOURCE
Resource Files
==============
A resource file has added to your project.  To make changes to the resource file, use the "VB Resource (RES) Editor" add-in.
*END

*INSTRUCT1
The Application Wizard has finished creating your application.  Throughout the project, you will find code comments indicating what you should do to add your own functionality to the project.  Search for "ToDo" in the comments within the project for more information.

What To Do Next
===============
You can save this report by clicking the "Save" button, or you can discard it by clicking "Close".  Once you are returned to the Visual Basic environment, run your application!  Press F5 or choose Start from the Run menu.
*END

*INSTRUCT2A
The Application Wizard has created the foundation for your application.  You can begin by editing the project to fit your needs.
*END

*INSTRUCT2B
The Application Wizard has created the foundation for your application.  You can begin by editing the project to fit your needs or you can run these other Wizards to provide more functionality:

Data Form Wizard - Add more complex forms based upon your local or remote data sources to your application.

Class Builder - Provide a rich object model for your application using this tool.

ActiveX Document Wizard - Translate any of the forms in your application to ActiveX Documents using this wizard.
*END


*BROWSER
Public StartingAddress As String
Dim mbDontNavigateNow As Boolean

Private Sub brwWebBrowser_DownloadComplete()
  On Error Resume Next
  Me.Caption = brwWebBrowser.LocationName
End Sub

Private Sub brwWebBrowser_NavigateComplete2(ByVal pDisp As Object, URL As Variant)
  On Error Resume Next
  Dim i As Integer
  Dim bFound As Boolean
  Me.Caption = brwWebBrowser.LocationName
  For i = 0 To cboAddress.ListCount - 1
    If cboAddress.List(i) = brwWebBrowser.LocationURL Then
      bFound = True
      Exit For
    End If
  Next i
  mbDontNavigateNow = True
  If bFound Then
    cboAddress.RemoveItem i
  End If
  cboAddress.AddItem brwWebBrowser.LocationURL, 0
  cboAddress.ListIndex = 0
  mbDontNavigateNow = False
End Sub

Private Sub cboAddress_Click()
  If mbDontNavigateNow Then Exit Sub
  timTimer.Enabled = True
  brwWebBrowser.Navigate cboAddress.Text
End Sub

Private Sub cboAddress_KeyPress(KeyAscii As Integer)
  On Error Resume Next
  If KeyAscii = vbKeyReturn Then
    cboAddress_Click
  End If
End Sub

Private Sub Form_Resize()
  On Error Resume Next
  cboAddress.Width = Me.ScaleWidth - 100
  brwWebBrowser.Width = Me.ScaleWidth - 100
  brwWebBrowser.Height = Me.ScaleHeight - (picAddress.Top + picAddress.Height) - 100
End Sub

Private Sub timTimer_Timer()
  If brwWebBrowser.Busy = False Then
    timTimer.Enabled = False
    Me.Caption = brwWebBrowser.LocationName
  Else
    Me.Caption = "Working..."
  End If
End Sub

Private Sub tbToolBar_ButtonClick(ByVal Button As Button)
  On Error Resume Next

  timTimer.Enabled = True

  Select Case Button.Key
    Case "Back"
      brwWebBrowser.GoBack
    Case "Forward"
      brwWebBrowser.GoForward
    Case "Refresh"
      brwWebBrowser.Refresh
    Case "Home"
      brwWebBrowser.GoHome
    Case "Search"
      brwWebBrowser.GoSearch
    Case "Stop"
      timTimer.Enabled = False
      brwWebBrowser.Stop
      Me.Caption = brwWebBrowser.LocationName
  End Select

End Sub
*END